PC Users 1998 March

home *** CD-ROM | disk | FTP | other *** search

/ PC Users 1998 March / Pc Users extra 6.iso / pshare95 / prog / formula1 / vcform1.z / format2.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1997-09-19 | 29.9 KB | 846 lines

VERSION 4.00 Begin VB.Form Form1 Caption = "Palette Maker" ClientHeight = 5070 ClientLeft = 750 ClientTop = 1470 ClientWidth = 9690 Height = 5475 Icon = "format2.frx":0000 Left = 690 LinkTopic = "Form1" ScaleHeight = 5070 ScaleWidth = 9690 Top = 1125 Width = 9810 Begin VB.Frame Frame3 Caption = " Generate Palette " Height = 2655 Left = 180 TabIndex = 18 Top = 2280 Width = 4215 Begin VB.CommandButton cmdGenPalette Caption = "Generate" Height = 315 Left = 60 TabIndex = 33 Top = 2160 Width = 795 End Begin Threed.SSPanel SSPanel3 Height = 1935 Left = 3060 TabIndex = 30 Top = 540 Width = 975 _Version = 65536 _ExtentX = 1720 _ExtentY = 3413 _StockProps = 15 BackColor = 12632256 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BevelOuter = 1 Begin VB.OptionButton optBDelta Caption = "Bell" Height = 255 Index = 3 Left = 120 TabIndex = 45 Top = 1620 Width = 795 End Begin VB.OptionButton optBDelta Caption = "1/Log" Height = 255 Index = 2 Left = 120 TabIndex = 44 Top = 1380 Width = 795 End Begin VB.OptionButton optBDelta Caption = "Log" Height = 255 Index = 1 Left = 120 TabIndex = 43 Top = 1140 Width = 795 End Begin VB.OptionButton optBDelta Caption = "Linear" Height = 255 Index = 0 Left = 120 TabIndex = 42 Top = 900 Value = -1 'True Width = 795 End Begin VB.TextBox txtFrom Alignment = 1 'Right Justify Height = 285 Index = 2 Left = 240 TabIndex = 32 Text = "0" Top = 120 Width = 555 End Begin VB.TextBox TxtTo Alignment = 1 'Right Justify Height = 285 Index = 2 Left = 240 TabIndex = 31 Text = "255" Top = 480 Width = 555 End End Begin Threed.SSPanel SSPanel2 Height = 1935 Left = 1980 TabIndex = 27 Top = 540 Width = 975 _Version = 65536 _ExtentX = 1720 _ExtentY = 3413 _StockProps = 15 BackColor = 12632256 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BevelOuter = 1 Begin VB.OptionButton optGDelta Caption = "Bell" Height = 255 Index = 3 Left = 120 TabIndex = 41 Top = 1620 Width = 735 End Begin VB.OptionButton optGDelta Caption = "1/Log" Height = 255 Index = 2 Left = 120 TabIndex = 40 Top = 1380 Width = 735 End Begin VB.OptionButton optGDelta Caption = "Log" Height = 255 Index = 1 Left = 120 TabIndex = 39 Top = 1140 Width = 735 End Begin VB.OptionButton optGDelta Caption = "Linear" Height = 255 Index = 0 Left = 120 TabIndex = 38 Top = 900 Value = -1 'True Width = 735 End Begin VB.TextBox txtFrom Alignment = 1 'Right Justify Height = 285 Index = 1 Left = 240 TabIndex = 29 Text = "0" Top = 120 Width = 555 End Begin VB.TextBox TxtTo Alignment = 1 'Right Justify Height = 285 Index = 1 Left = 240 TabIndex = 28 Text = "255" Top = 480 Width = 555 End End Begin Threed.SSPanel SSPanel1 Height = 1935 Left = 900 TabIndex = 24 Top = 540 Width = 975 _Version = 65536 _ExtentX = 1720 _ExtentY = 3413 _StockProps = 15 BackColor = 12632256 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BevelOuter = 1 Begin VB.OptionButton optRDelta Caption = "Bell" Height = 255 Index = 3 Left = 120 TabIndex = 37 Top = 1620 Width = 735 End Begin VB.OptionButton optRDelta Caption = "1/Log" Height = 255 Index = 2 Left = 120 TabIndex = 36 Top = 1380 Width = 735 End Begin VB.OptionButton optRDelta Caption = "Log" Height = 255 Index = 1 Left = 120 TabIndex = 35 Top = 1140 Width = 735 End Begin VB.OptionButton optRDelta Caption = "Linear" Height = 255 Index = 0 Left = 120 TabIndex = 34 Top = 900 Value = -1 'True Width = 735 End Begin VB.TextBox txtFrom Alignment = 1 'Right Justify Height = 285 Index = 0 Left = 240 TabIndex = 26 Text = "0" Top = 120 Width = 555 End Begin VB.TextBox TxtTo Alignment = 1 'Right Justify Height = 285 Index = 0 Left = 240 TabIndex = 25 Text = "255" Top = 480 Width = 555 End End Begin VB.Label Label2 Alignment = 1 'Right Justify Caption = "To:" Height = 195 Index = 1 Left = 300 TabIndex = 23 Top = 1080 Width = 435 End Begin VB.Label Label1 Alignment = 2 'Center Caption = "Blue" Height = 195 Index = 5 Left = 3300 TabIndex = 22 Top = 300 Width = 555 End Begin VB.Label Label1 Alignment = 2 'Center Caption = "Green" Height = 195 Index = 4 Left = 2220 TabIndex = 21 Top = 300 Width = 555 End Begin VB.Label Label1 Alignment = 2 'Center Caption = "Red" Height = 195 Index = 3 Left = 1140 TabIndex = 20 Top = 300 Width = 555 End Begin VB.Label Label2 Alignment = 1 'Right Justify Caption = "From:" Height = 195 Index = 0 Left = 240 TabIndex = 19 Top = 660 Width = 495 End End Begin VB.Frame Frame2 Caption = " Cell Colors " Height = 1155 Left = 4560 TabIndex = 7 Top = 2400 Width = 3375 Begin VB.TextBox txtColor Alignment = 1 'Right Justify Height = 285 Index = 0 Left = 300 TabIndex = 10 Text = "255" Top = 630 Width = 495 End Begin VB.TextBox txtColor Alignment = 1 'Right Justify Height = 285 Index = 1 Left = 1320 TabIndex = 9 Text = "255" Top = 630 Width = 495 End Begin VB.TextBox txtColor Alignment = 1 'Right Justify Height = 285 Index = 2 Left = 2340 TabIndex = 8 Text = "255" Top = 630 Width = 495 End Begin VB.Label Label1 Alignment = 2 'Center Caption = "Red" Height = 195 Index = 0 Left = 300 TabIndex = 16 Top = 360 Width = 555 End Begin VB.Label Label1 Alignment = 2 'Center Caption = "Green" Height = 195 Index = 1 Left = 1320 TabIndex = 15 Top = 360 Width = 555 End Begin VB.Label Label1 Alignment = 2 'Center Caption = "Blue" Height = 195 Index = 2 Left = 2340 TabIndex = 14 Top = 360 Width = 555 End Begin Spin.SpinButton spnColor Height = 345 Index = 0 Left = 840 TabIndex = 13 Top = 600 Width = 225 _Version = 65536 _ExtentX = 397 _ExtentY = 609 _StockProps = 73 Delay = 100 ShadowThickness = 1 TdThickness = 1 End Begin Spin.SpinButton spnColor Height = 345 Index = 1 Left = 1860 TabIndex = 12 Top = 600 Width = 225 _Version = 65536 _ExtentX = 397 _ExtentY = 609 _StockProps = 73 Delay = 100 ShadowThickness = 1 TdThickness = 1 End Begin Spin.SpinButton spnColor Height = 345 Index = 2 Left = 2880 TabIndex = 11 Top = 600 Width = 225 _Version = 65536 _ExtentX = 397 _ExtentY = 609 _StockProps = 73 Delay = 100 ShadowThickness = 1 TdThickness = 1 End End Begin VB.Frame Frame1 Caption = " Display " Height = 1155 Left = 4560 TabIndex = 2 Top = 3660 Width = 3375 Begin VB.ComboBox cboPalette Height = 300 ItemData = "format2.frx":044A Left = 1860 List = "format2.frx":044C Style = 2 'Dropdown List TabIndex = 17 Top = 300 Width = 1335 End Begin VB.CommandButton cmdRefreshPalette Caption = "Refresh Palette" Height = 315 Left = 1860 TabIndex = 6 Top = 720 Width = 1335 End Begin VB.OptionButton optDecimal Caption = "As Decimal" Height = 255 Left = 540 TabIndex = 4 Top = 480 Value = -1 'True Width = 1155 End Begin VB.OptionButton optHex Caption = "As Hex" Height = 195 Left = 540 TabIndex = 3 Top = 780 Width = 1035 End Begin Threed.SSCheck chkShowNumbers Height = 255 Left = 240 TabIndex = 5 Top = 240 Width = 1515 _Version = 65536 _ExtentX = 2672 _ExtentY = 450 _StockProps = 78 Caption = "Show Numbers" BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Value = -1 'True End End Begin VB.TextBox txtFileName Height = 285 Left = 8220 TabIndex = 1 Text = "MyPalet1.txt" Top = 4320 Width = 1215 End Begin VB.CommandButton cmdSaveAs Caption = "Save As" Height = 345 Left = 8220 TabIndex = 0 Top = 3840 Width = 1215 End Begin VCF150Ctl.F1Book F1Book1 Height = 2115 Left = 180 TabIndex = 46 Top = 120 Width = 9255 _ExtentX = 16325 _ExtentY = 3731 _0 = $"format2.frx":044E _1 = $"format2.frx":0853 _2 = $"format2.frx":0C58 _3 = $"format2.frx":105C _4 = $"format2.frx":1461 _count = 5 _ver = 1 End Attribute VB_Name = "Form1" Attribute VB_Creatable = False Attribute VB_Exposed = False '' Format2 - a portable palette generator for Formula One 3.0 OCX '' Description: '' Allows you to view and alter a palette and then save the entries '' as VB code that you can later load into a project as a module to '' setup a custom palette. The palette is layed out as it appears in '' the custom color combo boxes (as on the FormatPatternDlg). '' The Formula One palette was designed with Excel compatibility in '' mind. The Excel palette has several (8) entries that are duplicates '' and can be improved upon for several situations. One is color '' coordinating a First Impression Chart with Formula One patterns. '' The Palette1 module was extracted from First Impression. Now that '' live charts can easily be placed on a Workbook, you can format your '' data to match chart series colors or even data point colors. '' This project also illustrates how handy Formula One can be as a programming '' aid. For instance, I constructed the code in the Palette1 module by '' copying the RGB values from First Impression into columns A, B, and C '' of a Formula One Workbook. In cell D1 I placed the formula '' =".PaletteEntry(" & ROW() & ") = RGB(" & A1 & "," & B1 & "," C1 & ")" '' and then copied that formula down to row 63. I then removed a couple '' of colors since the First Impression palette has more entries than '' the Formula One palette. This was simple since the palette entries '' were automatically fixed up when the row was deleted. Next, cut and paste '' into the VB code window which again saved much typing. Another way Formula '' One is used is as a text formatter. When you save a file in this '' project, the code is placed in Formula One and saved as a text file. '' Why use this? Often it is hard to get just the right look for the finished '' project. You want just the right colors and patterns for your formatting '' and spend a lot of time getting that look. This doesn't have much to do '' with the problem solving you are doing but in many cases is as important. '' Often you will find colors that suit you and want to use them over. '' This project provides a little different way of creating a palette but '' more importantly, allows you to save your work and easily reuse it. This '' allows you to spend more time on the important code - the code that solves '' the problem. If you build a collection of these reusable modules, you can '' leave a lot of the UI till the end and then easliy and quickly change it '' to suit customer desires. Option Explicit Private Sub cboPalette_Click() Select Case cboPalette.ListIndex Case 0: Call ChangeToPalette1(F1Book1) Case 1: Call ChangeToPalette2(F1Book1) Case 2: Call ChangeToPalette3(F1Book1) Case 3: Call ChangeToPalette4(F1Book1) Case 4: Call ChangeToPalette5(F1Book1) Case 5: Call ChangeToPalette6(F1Book1) Case 6: Call ChangeToPalette7(F1Book1) End Select Call cmdRefreshPalette_Click End Sub Private Sub chkShowNumbers_Click(Value As Integer) optDecimal.Enabled = Value optHex.Enabled = Value Call cmdRefreshPalette_Click End Sub Private Sub cmdGenPalette_Click() '' Uses settings in the Generate Palette Frame to set the '' Formula One palette. First two entries are always '' Black and white. Const kLINEAR = 0 Const kLOG = 1 Const kILOG = 2 Const kBELL = 3 Dim rmin%, rmax%, gmin%, gmax%, bmin%, bmax% Dim rval%, gval%, bval% Dim rType%, gType%, bType% Dim i% rmin = Val(txtFrom(0).Text) gmin = Val(txtFrom(1).Text) bmin = Val(txtFrom(2).Text) rmax = Val(TxtTo(0).Text) gmax = Val(TxtTo(1).Text) bmax = Val(TxtTo(2).Text) If optRDelta(0).Value = True Then rType = kLINEAR If optRDelta(1).Value = True Then rType = kLOG If optRDelta(2).Value = True Then rType = kILOG If optRDelta(3).Value = True Then rType = kBELL If optGDelta(0).Value = True Then gType = kLINEAR If optGDelta(1).Value = True Then gType = kLOG If optGDelta(2).Value = True Then gType = kILOG If optGDelta(3).Value = True Then gType = kBELL If optBDelta(0).Value = True Then bType = kLINEAR If optBDelta(1).Value = True Then bType = kLOG If optBDelta(2).Value = True Then bType = kILOG If optBDelta(3).Value = True Then bType = kBELL With F1Book1 .PaletteEntry(1) = 0 .PaletteEntry(2) = RGB(255, 255, 255) For i = 3 To 56 Select Case rType Case kLINEAR: rval = ((i / 56) * (rmax - rmin)) + rmin Case kLOG: rval = ((Log((i / 56) * 4)) * (rmax - rmin)) + rmin Case kILOG: rval = ((1 / (Log((i / 56) * 35))) * (rmax - rmin)) + rmin Case kBELL: rval = (Sin((i / 56) * 3.14) * (rmax - rmin)) + rmin End Select Select Case gType Case kLINEAR: gval = ((i / 56) * (gmax - gmin)) + gmin Case kLOG: gval = ((Log((i / 56) * 4)) * (gmax - gmin)) + gmin Case kILOG: gval = ((1 / (Log((i / 56) * 35))) * (gmax - gmin)) + gmin End Select Select Case bType Case kLINEAR: bval = ((i / 56) * (bmax - bmin)) + bmin Case kLOG: bval = ((Log((i / 56) * 4)) * (bmax - bmin)) + bmin Case kILOG: bval = ((1 / (Log((i / 56) * 35))) * (bmax - bmin)) + bmin End Select .PaletteEntry(i) = RGB(Abs(rval), Abs(gval), Abs(bval)) Next i End With Call cmdRefreshPalette_Click End Sub Private Sub cmdRefreshPalette_Click() Dim i&, j& With F1Book1 If chkShowNumbers.Value = False Then .ClearRange 1, 1, 7, 8, F1ClearAll For j = 1 To 8 For i = 1 To 7 .SetSelection i, j, i, j .SetPattern 1, .PaletteEntry(j + ((i - 1) * 8)), 0 If chkShowNumbers.Value = True Then If optDecimal.Value = True Then .NumberRC(i, j) = .PaletteEntry(j + ((i - 1) * 8)) Else .TextRC(i, j) = Hex(.PaletteEntry(j + ((i - 1) * 8))) End If End If Next i Next j End With End Sub Private Sub cmdSaveAs_Click() '' Formula One will not refresh the screen until we exit '' this procedure so we will write on it, save the file '' and then refresh the palette. Error checking is left '' as an exercise to the reader. The code uses numbers '' instead of the RGB function for speed. You can always '' add your saved palette back into this project to edit '' later. On Error GoTo FileWriteError Dim i& With F1Book1 .ClearRange -1, -1, -1, -1, F1ClearAll .TextRC(1, 1) = "Option Explicit" .TextRC(3, 1) = "Sub " & Left$(txtFileName.Text, Len(txtFileName.Text) - 4) & "()" .TextRC(5, 2) = "With F1Book1" For i = 1 To 56 .TextRC(i + 6, 3) = ".PaletteEntry(" & i & ") = " & .PaletteEntry(i) Next i .TextRC(64, 2) = "End With" .TextRC(65, 1) = "End Sub" .Write App.Path & "\" & txtFileName.Text, F1FileTabbedText '' Now set right alignment so the hex numbers look good .SetSelection -1, -1, -1, -1 .SetAlignment F1HAlignRight, False, F1VAlignBottom, 0 .Selection = "A1" End With Call cmdRefreshPalette_Click Exit Sub FileWriteError: MsgBox Error End Sub Private Sub optDecimal_Click() Call cmdRefreshPalette_Click End Sub Private Sub optHex_Click() Call cmdRefreshPalette_Click End Sub Private Sub F1Book1_Click(ByVal nRow As Long, ByVal nCol As Long) '' Gets the palette entry associated with a cell, cracks it '' into RGB and puts it in the color text boxes Dim r%, g%, b%, color& If nRow > 0 And nCol > 0 Then ' Ignore the col and row hdr clicks color = F1Book1.PaletteEntry(nCol + ((nRow - 1) * 8)) Call CrackColor(color, r, g, b) txtColor(0).Text = Str$(r) txtColor(1).Text = Str$(g) txtColor(2).Text = Str$(b) End If End Sub Private Sub Form_Load() F1Book1.Width = 9540 F1Book1.Height = 2070 Call cmdRefreshPalette_Click cboPalette.AddItem "First Impression" cboPalette.AddItem "Ochres" cboPalette.AddItem "Yellow-Greens" cboPalette.AddItem "Magentas" cboPalette.AddItem "Blues" cboPalette.AddItem "Cyan-Greens" cboPalette.AddItem "Cyan-Blues" End Sub Sub CrackColor(color&, r%, g%, b%) '' Breaks a long color into its component parts and returns '' in r, g, and b. Note that the ColorRef stores the color '' in 3 low order bytes as BGR. The hex function does not '' pad with zeroes so we use a select. Dim colorStr$, rStr$, gStr$, bStr$ Let colorStr = Hex(color) Select Case Len(colorStr) Case 1, 2: r = Val("&H" & colorStr) g = 0 b = 0 Case 3: r = Val("&H" & Right$(colorStr, 2)) g = Val("&H" & Left$(colorStr, 1)) b = 0 Case 4: r = Val("&H" & Right$(colorStr, 2)) g = Val("&H" & Left$(colorStr, 2)) b = 0 Case 5: r = Val("&H" & Right$(colorStr, 2)) g = Val("&H" & Mid$(colorStr, 2, 2)) b = Val("&H" & Left$(colorStr, 1)) Case 6: r = Val("&H" & Right$(colorStr, 2)) g = Val("&H" & Mid$(colorStr, 3, 2)) b = Val("&H" & Left$(colorStr, 2)) End Select End Sub Private Sub mnuCopy_Click() F1Book1.Write App.Path & "\foo.txt", F1FileExcel5 End Sub Private Sub spnColor_SpinDown(Index As Integer) '' Decrements the text box value and applies the new '' color to the palette entry corresponding to the selected '' cell in the worksheet. Decimals will appear to jump '' wildly. Use Hex view if you want them to increment '' smoothly. Dim num% num = Val(txtColor(Index).Text) - 1 If num > -1 Then txtColor(Index).Text = Str$(num) Call SetColor End If End Sub Private Sub spnColor_SpinUp(Index As Integer) '' Increments the text box value and applies the new '' color to the palette entry corresponding to the selected '' cell in the worksheet. Decimals will appear to jump '' wildly. Use Hex view if you want them to increment '' smoothly. Dim num% num = Val(txtColor(Index).Text) + 1 If num < 256 Then txtColor(Index).Text = Str$(num) Call SetColor End If End Sub Sub SetColor() Dim pNum& With F1Book1 pNum = .SelStartCol + ((.SelStartRow - 1) * 8) .PaletteEntry(pNum) = RGB(Val(txtColor(0).Text), Val(txtColor(1).Text), Val(txtColor(2).Text)) .SetPattern 1, .PaletteEntry(pNum), 0 If chkShowNumbers.Value = True Then If optDecimal.Value = True Then .Number = .PaletteEntry(pNum) Else .Text = Hex(.PaletteEntry(pNum)) End If End If End With End Sub Private Sub txtColor_KeyPress(Index As Integer, KeyAscii As Integer) '' If the user types a value in the text box and then hits return '' we will set the palette entry. If they enter an invalid number '' we set it to zero. This is a programmer's tool so we can be terse. Dim newNum% If KeyAscii = 13 Then newNum = Val(txtColor(Index).Text) If newNum > -1 And newNum < 256 Then txtColor(Index).Text = Str$(newNum) Else txtColor(Index).Text = 0 End If Call SetColor End If End Sub Private Sub txtFrom_KeyPress(Index As Integer, KeyAscii As Integer) If KeyAscii = 13 Then If Val(txtFrom(Index).Text) < 0 Or Val(txtFrom(Index).Text) > 255 Then txtFrom(Index).Text = "0" End If End If End Sub Private Sub TxtTo_KeyPress(Index As Integer, KeyAscii As Integer) If KeyAscii = 13 Then If Val(TxtTo(Index).Text) < 0 Or Val(TxtTo(Index).Text) > 255 Then TxtTo(Index).Text = "0" End If End If End Sub